home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / runtime / run_ml.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-09  |  7.3 KB  |  330 lines
  1. /* run_ml.c
  2.  *
  3.  * COPYRIGHT (c) 1990 by AT&T Bell Laboratories.
  4.  *
  5.  * These are routines for handling the ML/C interface.
  6.  */
  7.  
  8. #include "ml_state.h"
  9. #include "ml_types.h"
  10. #include "request.h"
  11. #include "cause.h"
  12. #include "prim.h"
  13. #include "sync.h"
  14. #include "eventchk.h"
  15.  
  16. /* This table maps the register numbers of the code generator to the proper
  17.  * indices of the root vector.  The order of entries in this table must
  18.  * respect both the MLState vector layout and the order of the miscregs in
  19.  * the C-machine implementation.  The pc, varptr, and exncont are not included.
  20.  */
  21. int        ArgRegMap[N_ARG_REGS] = {
  22.     LINK_INDX, CLOSURE_INDX, ARG_INDX, CONT_INDX,    /* the standard arg registers */
  23. #ifndef C
  24. #  if defined(RS6000)
  25.          9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23
  26. #  endif
  27. #  if defined(SPARC)
  28.     /* misc. regs = %g2-%g3, %o1-%o2, %l0-%l7, %i4; */
  29.      9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 8
  30. #  endif
  31. #  if defined(M68)
  32.       5
  33. #  endif
  34. #  if defined(VAX)
  35.      5, 6, 7, 8, 9
  36. #  endif
  37. #  if defined(MIPS)
  38.      6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18
  39. #  endif
  40. #  if defined(HPPA)
  41.      8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19
  42. #  endif
  43. #  if defined(NS32)
  44.      ??
  45. #  endif
  46. #  if defined(I386)
  47.      7, 8, 9
  48. #  endif
  49. #else /* !C */
  50.      6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21,
  51.      22, 23, 24, 25, 26
  52. #endif /* !C */
  53.     };
  54.  
  55. void raise_ml_exn ();
  56. static void uncaught ();
  57.  
  58. extern void check_heap ();
  59. extern void callgc0 ();
  60.  
  61. #ifdef C
  62. jmp_buf top_level;
  63. #endif
  64.  
  65. /* run_ml:
  66.  */
  67. static void run_ml (msp)
  68.      MLState_ptr msp;
  69. {
  70. #ifdef C
  71.   top: if (setjmp(top_level))
  72.           goto top;
  73. #endif
  74.     while (1) {
  75.  
  76. #ifdef ICOUNT
  77. /*      chatting("icount = %d\n", (msp->ml_icount));   */
  78.         msp->ml_icount = (ML_val_t)((int)(msp->ml_icount)+372);
  79.         while ((int)(msp->ml_icount) >= 1000000)
  80.       {extern int icountM;
  81.            msp->ml_icount = (ML_val_t)((int)(msp->ml_icount)-1000000);
  82.        icountM += 1;
  83.       }
  84. #endif
  85. #ifdef MP_DEBUG
  86.     pchatting(msp,"[req = %d]\n",msp->request);
  87. #endif MP_DEBUG
  88.     switch (msp->request) {
  89.       case REQ_RETURN:
  90. #ifdef GCMON
  91.         dumpMon(msp);
  92. #endif GCMON
  93.         return;
  94.  
  95.       case REQ_RUN:
  96.         break;
  97.  
  98.       case REQ_EXN: /* an uncaught exception */
  99.         uncaught (msp->ml_arg);
  100.         return;
  101.  
  102.       case REQ_FAULT: { /* a hardware fault */
  103.         raise_ml_exn (msp);
  104.         } break;
  105.  
  106.       case REQ_GC:
  107. #ifdef C
  108.         die("internal error: requested gc");
  109. #else
  110.         callgc0 (msp, CAUSE_GC, 
  111.              (msp->ml_limitptr + 4096) - (msp->ml_allocptr) + 4);
  112. #endif
  113.         gcsignal(msp);
  114.         break;
  115.  
  116.       case REQ_CALLC: {
  117.         int        (*f)();
  118.         ML_val_t    arg;
  119.  
  120. #if (CALLEESAVE > 0)
  121.         msp->ml_closure = ML_unit;
  122.                 msp->ml_pc = msp->ml_cont;
  123. #else 
  124.         msp->ml_closure = msp->ml_cont;
  125.         msp->ml_pc = msp->ml_linkreg = CODE_ADDR(msp->ml_cont);
  126. #endif
  127.  
  128.         msp->mask = CONT_ARGS_MASK;
  129.         check_heap (msp, 32768);
  130.  
  131.         f   = (int (*)())REC_SELPTR(msp->ml_arg, 0);
  132.         arg = REC_SEL(msp->ml_arg, 1);
  133.         (*f)(msp, arg);
  134. #ifdef C
  135.         msp->request = REQ_RUN;
  136.         goto top;
  137. #endif
  138.         } break;
  139.  
  140.       case REQ_SIGNAL: {
  141.         extern ML_val_t make_ml_sigh_arg(),sighandler0[];
  142.  
  143.         sig_setup(msp);
  144.         check_heap(msp, 4096);
  145.  
  146.         msp->ml_arg     = make_ml_sigh_arg(msp);
  147.         msp->ml_cont    = PTR_CtoML(sigh_return_c);
  148.         msp->ml_exncont = PTR_CtoML(handle_v+1);
  149.         msp->ml_closure = sighandler0[1];
  150.         msp->ml_pc  = msp->ml_linkreg = CODE_ADDR(msp->ml_closure);
  151. #ifdef C
  152.         msp->request = REQ_RUN;
  153.         goto top;
  154. #endif
  155.         } break;
  156.  
  157.       case REQ_SIG_RETURN: {
  158.           /* Handle the return from the ML signal handler.  The ml_arg
  159.            * contains the unit resumption continuation (2-arg fn).
  160.            */
  161.         register ML_val_t kont = msp->ml_arg;
  162.  
  163.           /* throw to the cont that we have received as an argument. */
  164.         msp->ml_arg     = ML_unit;
  165. #if (CALLEESAVE > 0)
  166.         msp->ml_closure = kont;
  167.         msp->ml_cont    = ML_unit;
  168. #else 
  169.         msp->ml_closure = ML_unit;
  170.         msp->ml_cont    = kont;
  171. #endif
  172.         msp->ml_pc = msp->ml_linkreg = CODE_ADDR(kont);
  173.         msp->ml_exncont = ML_unit;
  174.           /* Note that we have finished handling the signal */
  175.         msp->inSigHandler = 0;
  176. #ifdef C
  177.         msp->request = REQ_RUN;
  178.         goto top;
  179. #endif
  180.         } break;
  181.  
  182.       case REQ_SIG_RESUME:
  183.         load_resume_state(msp);
  184.         break;
  185.  
  186.       default:
  187.         die ("internal error: unknown request code = %d\n", msp->request);
  188.         break;
  189.     } /* end of switch */
  190.  
  191.     msp->request = REQ_GC;
  192.         restoreregs(msp);
  193.  
  194.     MAYBE_EVENTCHK();
  195.     }
  196.  
  197. } /* end of run_ml. */
  198.  
  199.  
  200. /* initialization for a new processor running ML code */
  201. void proc_body (msp)
  202.     MLState_ptr msp;
  203. {
  204.     extern spin_lock_t MLproc_lock;
  205.  
  206.     setup_signals(msp, TRUE);
  207.   /* spin until we get our id */
  208.     while (msp->self == 0)
  209.     continue;
  210. #ifdef MP_DEBUG
  211.     pchatting(msp,"[releasing lock]\n");
  212. #endif MP_DEBUG
  213.     spin_unlock (MLproc_lock); /* implicitly handed to the child by the parent */
  214.     run_ml (msp);
  215.   /* should never return */
  216.     die ("proc returned after run_ml() in proc_body().\n");
  217.  
  218. } /* end of proc_body */
  219.  
  220.  
  221. /* raise_ml_exn:
  222.  * Modify the ML state, so that the given exception will be raised when ML is resumed.
  223.  */
  224. void raise_ml_exn (msp)
  225.      MLState_ptr msp;
  226. {
  227.     ML_val_t            exn = msp->fault_exn;
  228.     register ML_val_t    kont = msp->ml_exncont;
  229.  
  230.     msp->ml_arg        = exn;
  231. #if (CALLEESAVE > 0)
  232.     msp->ml_closure    = kont;
  233. #else 
  234.     msp->ml_cont    = kont;
  235. #endif
  236.     msp->ml_pc = msp->ml_linkreg = CODE_ADDR(kont);
  237.  
  238. } /* end of raise_ml_exn. */
  239.  
  240.  
  241. int profile_array[201] = {MAKE_DESC(200,TAG_array),
  242. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  243. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  244. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  245. 1,1,1,1,1,1,1,1,1,1, 
  246.  
  247. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  248. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  249. 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 
  250. 1,1,1,1,1,1,1,1,1,1 };
  251.  
  252. /* apply_ml_fn:
  253.  * Apply the ML closure f to arg and return the result.
  254.  */
  255. ML_val_t apply_ml_fn (msp, f, arg)
  256.     MLState_ptr     msp;
  257.     ML_val_t        f, arg;
  258. {
  259.     register int    i;
  260.  
  261.   /* clear the ML root registers */
  262.     for (i = 0;  i < NROOTS;  i++)
  263.     msp->ml_roots[i] = ML_unit;
  264.  
  265.   /* initialize the calling context */
  266.     msp->ml_exncont    = PTR_CtoML(handle_v+1);
  267.     msp->ml_varptr      = PTR_CtoML(profile_array+1);
  268.     msp->ml_arg        = arg;
  269.     msp->ml_cont    = PTR_CtoML(return_c);
  270.     msp->ml_closure    = f;
  271.     msp->ml_pc = msp->ml_linkreg = CODE_ADDR(f);
  272.     msp->request    = REQ_RUN;
  273.  
  274.     run_ml (msp);
  275.  
  276.     return msp->ml_arg;
  277.  
  278. } /* end of apply_ml_fn */
  279.  
  280.  
  281. /* restart_ml:
  282.  * Restart an exported ML system.
  283.  */
  284. void restart_ml ()
  285. {
  286.     extern MLState_ptr mp_init();
  287.  
  288.     MLState_ptr        msp = mp_init(TRUE);
  289.  
  290.     restart_gc (msp);
  291.     setup_signals (msp, TRUE);
  292.  
  293.     msp->ml_arg = ML_true;
  294.     msp->request = REQ_RUN;
  295.     run_ml (msp);
  296.       
  297. #ifdef ADVICE
  298.     call_endadvice(msp);
  299. #endif
  300.  
  301.     mp_shutdown(msp,0);
  302.  
  303. } /* end of restart_ml */
  304.  
  305.  
  306. /* uncaught:
  307.  * Handle an uncaught exception.
  308.  */
  309. static void uncaught (e)
  310.     ML_val_t    e;
  311. {
  312.     ML_val_t    val = REC_SEL(e, 1);
  313.     ML_val_t    name = REC_SEL(REC_SEL(e, 0), 0);
  314.  
  315.     chatting("Uncaught exception %.*s with ", OBJ_LEN(name), PTR_MLtoC(name));
  316.  
  317.     if (! OBJ_isBOXED(val))
  318.     chatting("%d\n", INT_MLtoC(val));
  319.     else {
  320.     int tag = OBJ_TAG(val);
  321.     if ((tag == TAG_string) || (tag == TAG_emb_string))
  322.         chatting("\"%.*s\"\n", OBJ_LEN(val), PTR_MLtoC(val));
  323.     else
  324.         chatting("<unknown>\n");
  325.     }
  326.  
  327.     mp_shutdown(find_self(),1);
  328.  
  329. } /* end of uncaught */
  330.